home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / intc.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  37KB  |  1,369 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* continuation of interpreter procedures - part c */
  10.  
  11. /* include standard header files */
  12. #include <stdlib.h>
  13. #include "config.h"
  14. #include "int.h"
  15. #include "ivars.h"
  16. #include "machinep.h"
  17. #include "farithp.h"
  18. #include "intap.h"
  19. #include "intbp.h"
  20. #include "intcp.h"
  21.  
  22. static int get_variable_bound(int *, int []);
  23.  
  24. void rselect(int field)                                                 /*;rselect*/
  25. {
  26.     /*
  27.      *   Perform the Ada record selection operation:
  28.      *
  29.      *     Get the address of the record type template from the TOS
  30.      *     Get the address of the record object from the TOS
  31.      *     Get the number of the component(or field) from the instruction
  32.      *     stream
  33.      *
  34.      *     Check the existence of that particular component in that particular
  35.      *     record(and raise CONSTRAINT_ERROR otherwise)
  36.      *
  37.      *     Push the absolute address of the component on TOS. If component
  38.      *     is an array, push also the address of the array type template.
  39.      *     If the type of this array depends on a discriminant of the  record
  40.      *     a template must be dynamically built.
  41.      */
  42.  
  43.     int
  44.     type_base, type_off, record_base, record_off, field_offset,
  45.         *type_ptr, *record_ptr, *field_table_ptr, *case_table_ptr,
  46.         *case_ptr, type_type, next_case, discr_number, discr_offset,
  47.         first_field, last_field, value_discr, val_high, nb_choices,
  48.         nb_field, nb_fixed, *field_ptr, *component_ptr, *a_type_ptr,
  49.         *u_type_ptr, nb_dim, low, high, comp_off, comp_base, component_size,
  50.         object_size, template_size, *new_type_ptr, *some_ptr;
  51.  
  52.     POP_ADDR(type_base, type_off);
  53.     POP_ADDR(record_base, record_off);
  54.     type_ptr = ADDR(type_base, type_off);
  55.     record_ptr = ADDR(record_base, record_off);
  56.     type_type = TYPE(type_ptr);
  57.  
  58.     /* constrained record subtype */
  59.  
  60.     if (type_type == TT_C_RECORD) {         /* find base type */
  61.         type_base = C_RECORD(type_ptr)->cbase;
  62.         type_off = C_RECORD(type_ptr)->coff;
  63.         type_ptr = ADDR(type_base, type_off);
  64.         type_type = TYPE(type_ptr);
  65.     }
  66.     else if (type_type == TT_D_RECORD) {
  67.         type_base = D_TYPE(type_ptr)->dbase;
  68.         type_off = D_TYPE(type_ptr)->doff;
  69.         type_ptr = ADDR(type_base, type_off);
  70.         type_type = TYPE(type_ptr);
  71.     }
  72.     else if (type_type == TT_RECORD) {
  73.         field_table_ptr = type_ptr + WORDS_RECORD;
  74.         nb_fixed = RECORD(type_ptr)->nb_field;
  75.     }
  76.  
  77.     if (type_type == TT_U_RECORD || type_type == TT_V_RECORD) {
  78.         nb_fixed = U_RECORD(type_ptr)->nb_fixed_u;
  79.         nb_field = U_RECORD(type_ptr)->nb_field_u;
  80.         field_table_ptr = type_ptr + WORDS_U_RECORD;
  81.         case_table_ptr = field_table_ptr + 3 * nb_field;
  82.     }
  83.  
  84.     /* The result is simple to obtain... unless the record has varying size */
  85.  
  86.     if (type_type == TT_V_RECORD) {
  87.         field_offset = 0;
  88.         first_field = 0;
  89.         last_field = nb_fixed - 1;
  90.         next_case = U_RECORD(type_ptr)->first_case;
  91.         nb_discr = U_RECORD(type_ptr)->nb_discr_u;
  92.  
  93.         for (i = 0; i < nb_discr; i++)
  94.             discr_list[i] = *(record_ptr + i);
  95.  
  96.         for (;;) {
  97.             field_ptr = 3 * first_field + field_table_ptr;
  98.             for (i = first_field; i <= MIN((field - 1), last_field); i++) {
  99.                 /* accumulate size of components */
  100.                 component_ptr = ADDR(*(field_ptr + 1), *(field_ptr + 2));
  101.                 field_offset += actual_size(component_ptr, discr_list);
  102.                 field_ptr += 3;
  103.             }
  104.  
  105.             if (field >= first_field && field <= last_field) {
  106.                 break;
  107.             }
  108.             else if (field < first_field  
  109.               ||(field > last_field && next_case == -1)) {
  110.  
  111.                 raise(CONSTRAINT_ERROR, "Record component not present");
  112.                 return;
  113.             }
  114.  
  115.             /*  We have : field > last_field and next_case /= -1 */
  116.  
  117.             case_ptr = case_table_ptr + next_case;
  118.             discr_number = *case_ptr++;
  119.             discr_offset = *(field_table_ptr + 3 * discr_number);
  120.             value_discr = *(record_ptr + discr_offset);
  121.             nb_choices = *case_ptr;
  122.             case_ptr += 4;
  123.             val_high = *case_ptr;
  124.             for (i = 2; i <= nb_choices; i++) {
  125.                 if (val_high > value_discr)
  126.                     break;
  127.                 case_ptr += 4;
  128.                 val_high = *case_ptr;
  129.             }
  130.             next_case = *--case_ptr;
  131.             last_field = *--case_ptr;
  132.             first_field = *--case_ptr;
  133.         }
  134.         field_ptr = field_table_ptr + 3 * field;
  135.     }
  136.  
  137.     /* Record is not varying */
  138.  
  139.     else {
  140.         field_ptr = field_table_ptr + 3 * field;
  141.         field_offset = *field_ptr;
  142.     }
  143.  
  144.     PUSH_ADDR(record_base, field_offset + record_off);
  145.  
  146.     /* check if component is an array */
  147.  
  148.     type_base = *(field_ptr + 1);
  149.     type_off = *(field_ptr + 2);
  150.     type_type = TYPE(ADDR(type_base, type_off));
  151.  
  152.     if ( type_type == TT_S_ARRAY
  153.       || type_type == TT_U_ARRAY
  154.       || type_type == TT_C_ARRAY
  155.       || type_type == TT_D_ARRAY) {
  156.  
  157.         if (type_type == TT_D_ARRAY) {
  158.             /* must build a type template */
  159.             /* necessarily the record is a TT_V_RECORD or a TT_U_RECORD with */
  160.             /* default values for the discriminants */
  161.             nb_discr = U_RECORD(type_ptr)->nb_discr_u;
  162.             for (i = 0; i < nb_discr; i++)
  163.                 discr_list[i] = *(record_ptr + i);
  164.             a_type_ptr = ADDR(type_base, type_off);
  165.             nb_dim = D_TYPE(a_type_ptr)->nb_discr_d;
  166.             type_base = D_TYPE(a_type_ptr)->dbase;
  167.             type_off = D_TYPE(a_type_ptr)->doff;
  168.             u_type_ptr = ADDR(type_base, type_off);
  169.             a_type_ptr += WORDS_D_TYPE;/* =bounds */
  170.             type_type = *u_type_ptr;
  171.  
  172.             if (nb_dim == 1) {
  173.                 /* unidimensional case: we build an s_array */
  174.                 low = get_variable_bound(a_type_ptr, discr_list);
  175.                 a_type_ptr += 2;
  176.                 high = get_variable_bound(a_type_ptr, discr_list);
  177.                 if (type_type == TT_S_ARRAY) {
  178.                     component_size = S_ARRAY(u_type_ptr)->component_size;
  179.                 }
  180.                 else {
  181.                     comp_base = ARRAY(u_type_ptr)->component_base;
  182.                     comp_off = ARRAY(u_type_ptr)->component_offset;
  183.                     component_size = SIZE(ADDR(comp_base, comp_off));
  184.                 }
  185.                 object_size = component_size *(high - low + 1);
  186.                 if (object_size < 0)
  187.                     object_size = 0;
  188.  
  189.                 create(WORDS_S_ARRAY, &type_base, &type_off, &new_type_ptr);
  190.                 S_ARRAY(new_type_ptr)->ttype = TT_S_ARRAY;
  191.                 S_ARRAY(new_type_ptr)->object_size = object_size;
  192.                 S_ARRAY(new_type_ptr)->component_size = component_size;
  193.                 S_ARRAY(new_type_ptr)->index_size = 1;
  194.                 S_ARRAY(new_type_ptr)->salow = low;
  195.                 S_ARRAY(new_type_ptr)->sahigh = high;
  196.             }
  197.  
  198.             else {        /* nb_dim > 1 */
  199.                 template_size = 2 *(nb_dim - 1) + WORDS_ARRAY;
  200.                 create(template_size, &type_base, &type_off, &new_type_ptr);
  201.                 ARRAY(new_type_ptr)->ttype = TT_C_ARRAY;
  202.                 ARRAY(new_type_ptr)->dim = nb_dim;
  203.                 comp_base = ARRAY(u_type_ptr)->component_base;
  204.                 comp_off = ARRAY(u_type_ptr)->component_offset;
  205.                 ARRAY(new_type_ptr)->component_base = comp_base;
  206.                 ARRAY(new_type_ptr)->component_offset = comp_off;
  207.                 component_size = SIZE(ADDR(comp_base, comp_off));
  208.                 /* Beware: indices in reverse order */
  209.                 some_ptr = new_type_ptr + WORDS_ARRAY + 2 * nb_dim - 3;
  210.                 for (i = 1; i <= nb_dim; i++) {
  211.                     low = get_variable_bound(a_type_ptr, discr_list);
  212.                     a_type_ptr += 2;
  213.                     high = get_variable_bound(a_type_ptr, discr_list);
  214.                     a_type_ptr += 2;
  215.                     create(WORDS_I_RANGE, &bas2, &off2, &ptr2);
  216.                     TYPE(ptr2) = TT_I_RANGE;
  217.                     SIZE(ptr2) = 1;
  218.                     I_RANGE(ptr2)->ilow = low;
  219.                     I_RANGE(ptr2)->ihigh = high;
  220.                     *some_ptr-- = off2;
  221.                     *some_ptr-- = bas2;
  222.                     if (high >= low)
  223.                         component_size *= (high - low + 1);
  224.                     else
  225.                         component_size = 0;
  226.                 }
  227.                 SIZE(new_type_ptr) = component_size;
  228.             }
  229.         }
  230.         PUSH_ADDR(type_base, type_off);
  231.     }
  232.  
  233.     /*  no check to perform if done already for varying size records */
  234.  
  235.     if (type_type == TT_V_RECORD)
  236.         return;
  237.  
  238.     first_field = 0;
  239.     last_field = nb_fixed - 1;
  240.     next_case = U_RECORD(type_ptr)->first_case;
  241.  
  242.     for (;;) {
  243.         if ((field >= first_field) &&(field <= last_field)) {
  244.             return;
  245.         }
  246.         else if (field < first_field 
  247.             ||(field > last_field && next_case == -1)) {
  248.             raise(CONSTRAINT_ERROR, "Record component not present");
  249.             return;
  250.         }
  251.  
  252.         /*  then we have : field > last_field and next_case /= -1 */
  253.  
  254.         case_ptr = case_table_ptr + next_case;
  255.         discr_number = *case_ptr++;
  256.         discr_offset = *(field_table_ptr + 3 * discr_number);
  257.         value_discr = *(record_ptr + discr_offset);
  258.         nb_choices = *case_ptr;
  259.         case_ptr += 4;
  260.         val_high = *case_ptr;
  261.         for (i = 2; i <= nb_choices; i++) {
  262.             if (val_high > value_discr) {
  263.                 break;
  264.             }
  265.             case_ptr += 4;
  266.             val_high = *case_ptr;
  267.         }
  268.         next_case = *--case_ptr;
  269.         last_field = *--case_ptr;
  270.         first_field = *--case_ptr;
  271.     }
  272.  
  273. }
  274.  
  275. static int get_variable_bound(int *bound_ptr, int discr_list[])
  276.                                                         /*;get_variable_bound*/
  277. {
  278.     int bound = *(bound_ptr + 1);
  279.     if (*bound_ptr == 1)
  280.         bound = discr_list[bound];
  281.     return bound;
  282. }
  283.  
  284. int actual_size(int *type_ptr, int discr_list[])                /*;actual_size*/
  285. {
  286.     /*
  287.      *     Returns the actual size of an object of the type designated by
  288.      *     type_ptr, with the discriminants of the enclosing record
  289.      *     given by discr_list
  290.      *
  291.      *     the real problem arises with discriminant dependant types and
  292.      *     varying length records(or their subtypes)
  293.      */
  294.  
  295.     int     new_discr_list[MAX_DISCR];
  296.     int    *base_type_ptr, *discr_ptr, nb_discr, i, size, *component_ptr;
  297.     int        nb_dim, low, high;
  298.     int     nb_field, nb_fixed, *field_ptr, *case_table_ptr, *field_table_ptr;
  299.     int     first_field, last_field, next_case, *case_ptr;
  300.     int     discr_number, value_discr, nb_choices;
  301.  
  302.     if (TYPE(type_ptr) == TT_D_RECORD) {
  303.         base_type_ptr = ADDR(D_TYPE(type_ptr)->dbase, D_TYPE(type_ptr)->doff);
  304.         discr_ptr = type_ptr + WORDS_D_TYPE;
  305.         nb_discr = D_TYPE(type_ptr)->nb_discr_d;
  306.         for (i = 0; i < nb_discr; i++) {
  307.             new_discr_list[i] = get_variable_bound(discr_ptr, discr_list);
  308. #ifdef TBSN
  309.             *discr_ptr++ = 0; /* To be checked: patch the template */
  310.             *discr_ptr++ = new_discr_list[i];
  311. #endif
  312.             discr_ptr += 2;
  313.         }
  314.         size = actual_size(base_type_ptr, new_discr_list);
  315.         SIZE(type_ptr) = size;
  316.     }
  317.  
  318.     else if (TYPE(type_ptr) == TT_D_ARRAY) {
  319.         base_type_ptr = ADDR(D_TYPE(type_ptr)->dbase, D_TYPE(type_ptr)->doff);
  320.         discr_ptr = type_ptr + WORDS_D_TYPE;
  321.         nb_dim = D_TYPE(type_ptr)->nb_discr_d;
  322.  
  323.         if ( TYPE(base_type_ptr) == TT_U_ARRAY
  324.           || TYPE(base_type_ptr) == TT_C_ARRAY) {
  325.             component_ptr =
  326.               ADDR(ARRAY(base_type_ptr)->component_base,
  327.               ARRAY(base_type_ptr)->component_offset);
  328. #ifdef TBSL
  329.             -- note review use of NULL corresponding to setl []  ds 9-30-85
  330. #endif
  331.                 size = actual_size(component_ptr, NULL_INT);
  332.         }
  333.         else if (TYPE(base_type_ptr) == TT_S_ARRAY) {
  334.             size = S_ARRAY(base_type_ptr)->component_size;
  335.         }
  336.  
  337.         for (i = 1; i <= nb_dim; i++) {
  338.             low = get_variable_bound(discr_ptr, discr_list);
  339. #ifdef TBSN
  340.             *discr_ptr++ = 0; /* to be checked: patch the template */
  341.             *discr_ptr++ = low;
  342. #endif
  343.             discr_ptr += 2;
  344.             high = get_variable_bound(discr_ptr, discr_list);
  345. #ifdef TBSN
  346.             *discr_ptr++ = 0; /* to be checked: patch the template */
  347.             *discr_ptr++ = high;
  348. #endif
  349.             discr_ptr += 2;
  350.             size = size *(MAX(0, high - low + 1));
  351.         }
  352.         SIZE(type_ptr) = size;
  353.     }
  354.     else if (TYPE(type_ptr) == TT_C_RECORD) {
  355.         if ((size = SIZE(type_ptr)) < 0) {
  356.             base_type_ptr = ADDR(C_RECORD(type_ptr)->cbase,
  357.               C_RECORD(type_ptr)->coff);
  358.             nb_discr = C_RECORD(type_ptr)->nb_discr_c;
  359.             for (i = 0; i < nb_discr; i++)
  360.                 new_discr_list[i] = *(type_ptr + WORDS_C_RECORD + i);
  361.             size = actual_size(base_type_ptr, new_discr_list);
  362.         }
  363.     }
  364.  
  365.     else if (TYPE(type_ptr) == TT_V_RECORD) {
  366.         nb_field = U_RECORD(type_ptr)->nb_field_u;
  367.         nb_fixed = U_RECORD(type_ptr)->nb_fixed_u;
  368.         field_table_ptr = type_ptr + WORDS_U_RECORD;
  369.         case_table_ptr = field_table_ptr + 3 * nb_field;
  370.         size = 0;
  371.         first_field = 0;
  372.         last_field = nb_fixed - 1;
  373.         next_case = U_RECORD(type_ptr)->first_case;
  374.         for (;;) {
  375.             field_ptr = 3 * first_field + field_table_ptr;
  376.             for (i = first_field; i <= last_field; i++) {
  377.                 /* accumulate size of components */
  378.                 component_ptr = ADDR(*(field_ptr + 1), *(field_ptr + 2));
  379.                 size += actual_size(component_ptr, discr_list);
  380.                 field_ptr += 3;
  381.             }
  382.  
  383.             if (next_case == -1)
  384.                 break;
  385.  
  386.             /* we have : next_case != -1 */
  387.  
  388.             case_ptr = case_table_ptr + next_case;
  389.             discr_number = *case_ptr++;
  390.             value_discr = discr_list[discr_number];
  391.             nb_choices = *case_ptr;
  392.             case_ptr += 4;
  393.             val_high = *case_ptr;
  394.             for (i = 2; i <= nb_choices; i++) {
  395.                 if (val_high > value_discr)
  396.                     break;
  397.                 case_ptr += 4;
  398.                 val_high = *case_ptr;
  399.             }
  400.             next_case = *--case_ptr;
  401.             last_field = *--case_ptr;
  402.             first_field = *--case_ptr;
  403.         }
  404.     }
  405.  
  406.     else
  407.         size = SIZE(type_ptr);
  408.  
  409.     return size;
  410. }
  411.  
  412. void record_move(int *ptr_a, int *ptr_v, int *ptr_t)       /*;record_move*/
  413. {
  414.     int    discr;
  415.  
  416.     length1 = SIZE(ptr_t);
  417.  
  418.     switch(TYPE(ptr_t)) {
  419.  
  420.     case TT_RECORD:
  421.         break;
  422.  
  423.     case TT_D_RECORD:
  424.         nb_discr = D_TYPE(ptr_t)->nb_discr_d;
  425.         ptr_a++;        /* skip constrained flag */
  426.         ptr_v++;
  427.         length1 -= nb_discr--;
  428.         i = nb_discr;
  429.         while (i-- > 0) {
  430.             if (*ptr_a++ != *ptr_v++) {
  431.                 raise(CONSTRAINT_ERROR, "Discriminant");
  432.                 return;
  433.             }
  434.         }
  435.         break;
  436.  
  437.     case TT_C_RECORD:
  438.     case TT_U_RECORD:
  439.  
  440.         /*     the type given must not be trusted, as this may be an assignment
  441.          * to some unconstrained out or in out parameter, in which case the
  442.          *     status constrained is inherited from the actual
  443.          */
  444.  
  445.         if (*ptr_a == 0) {     /* unconstrained */
  446.  
  447.             length1--;    /* constrained flag is not copied ! */
  448.             ptr_a++;
  449.             ptr_v++;
  450.             for (i = 0; i < length1; i++)
  451.                 *ptr_a++ = *ptr_v++;
  452.             return;
  453.         }
  454.         else {
  455.             if (TYPE(ptr_t) == TT_C_RECORD)
  456.                 nb_discr = C_RECORD(ptr_t)->nb_discr_c;
  457.             else
  458.                 nb_discr = U_RECORD(ptr_t)->nb_discr_u;
  459.             ptr_a++;    /* skip contrained flag */
  460.             ptr_v++;
  461.             length1 -= nb_discr--;
  462.             i = nb_discr;
  463.             while(i-- > 0) {
  464.                 if (*ptr_a++ != *ptr_v++) {
  465.                     raise(CONSTRAINT_ERROR, "Discriminant");
  466.                     return;
  467.                 }
  468.             }
  469.         }
  470.         break;
  471.  
  472.     case TT_V_RECORD:
  473.         if (*ptr_a == 0) {    /* unconstrained */
  474.             /* constrained flag is not copied ! */
  475.             length1--;
  476.             ptr_a++;
  477.             ptr_v++;
  478.             if (TYPE(ptr_t) == TT_C_RECORD)
  479.                 nb_discr = C_RECORD(ptr_t)->nb_discr_c;
  480.             else
  481.                 nb_discr = U_RECORD(ptr_t)->nb_discr_u;
  482.             discr_list[0] = *ptr_a;
  483.             for (i = 1; i < nb_discr; i++) {
  484.                 /*
  485.                 discr = *ptr_a++;
  486.                 discr_list[i] = discr;
  487.                 if (discr != *ptr_v++) 
  488.                 raise(CONSTRAINT_ERROR, "Discriminant");
  489.                 return;
  490.                 */
  491.                 discr_list [i] = *ptr_v;
  492.                 *ptr_a++ = *ptr_v++;
  493.             }
  494.             length1 = actual_size(ptr_t, discr_list) - nb_discr;
  495.             for (i = 0; i < length1; i++)
  496.                 *ptr_a++ = *ptr_v++;
  497.             return;
  498.         }
  499.         else {
  500.             if (TYPE(ptr_t) == TT_C_RECORD)
  501.                 nb_discr = C_RECORD(ptr_t)->nb_discr_c;
  502.             else
  503.                 nb_discr = U_RECORD(ptr_t)->nb_discr_u;
  504.             discr_list[0] = *ptr_a;
  505.             ptr_a++;    /* skip constrained flag */
  506.             ptr_v++;
  507.             for (i = 1; i < nb_discr; i++) {
  508.                 discr = *ptr_a++;
  509.                 discr_list[i] = discr;
  510.                 if (discr != *ptr_v++) {
  511.                     raise(CONSTRAINT_ERROR, "Discriminant");
  512.                     return;
  513.                 }
  514.             }
  515.             length1 = actual_size(ptr_t, discr_list) - nb_discr;
  516.         }
  517.         break;
  518.     }
  519.  
  520.     for (i = 0; i < length1; i++)
  521.         *ptr_a++ = *ptr_v++;
  522. }
  523.  
  524. void membership()                                                /*;membership*/
  525. {
  526.     int     some_bool;
  527.  
  528.     POP_ADDR(bse, off);
  529.  
  530.     switch(TYPE(ADDR(bse, off))) {
  531.  
  532.     case TT_I_RANGE:
  533.     case TT_E_RANGE:
  534.     case TT_ENUM:
  535.         POP(value);
  536.         PUSH((I_RANGE(ADDR(bse, off))->ilow <=
  537.           I_RANGE(ADDR(bse,off))->ihigh) &&
  538.           (value >= I_RANGE(ADDR(bse, off))->ilow &&
  539.           value <= I_RANGE(ADDR(bse, off))->ihigh));
  540.         break;
  541.  
  542.     case TT_FL_RANGE:
  543.         POPF(rvalue);
  544.         PUSH((FL_RANGE(ADDR(bse, off))->fllow <=
  545.           FL_RANGE(ADDR(bse,off))->flhigh) &&
  546.           (rvalue >= FL_RANGE(ADDR(bse, off))->fllow &&
  547.           rvalue <= FL_RANGE(ADDR(bse, off))->flhigh));
  548.         break;
  549.  
  550.     case TT_FX_RANGE:
  551.         POPL(lvalue);
  552.         PUSH((FX_RANGE(ADDR(bse, off))->fxlow <=
  553.           FX_RANGE(ADDR(bse,off))->fxhigh) &&
  554.           (lvalue >= FX_RANGE(ADDR(bse, off))->fxlow &&
  555.           lvalue <= FX_RANGE(ADDR(bse, off))->fxhigh));
  556.         break;
  557.  
  558.     case TT_C_RECORD:
  559.         ptr1 = ADDR(bse, off);
  560.         POP_ADDR(bse, off);
  561.         ptr2 = ADDR(bse, off);
  562.         nb_discr = C_RECORD(ptr1)->nb_discr_c;
  563.         some_bool = TRUE;
  564.         ptr1 += WORDS_C_RECORD;
  565.         for (i = 1; i < nb_discr; i++)
  566.             if (*++ptr2 != *++ptr1) {
  567.                 some_bool = FALSE;
  568.             }
  569.         PUSH(some_bool);
  570.         break;
  571.  
  572.     case TT_V_RECORD:
  573.     case TT_U_RECORD:
  574.         POP_ADDR(bse, off);
  575.         PUSH(TRUE);
  576.         break;
  577.  
  578.     /* If the array type is unconstrained, the value must be within the
  579.      * given bounds. If constrained bounds must be the same. This rule is
  580.      * the same for null arrays.
  581.      */
  582.     case TT_U_ARRAY:
  583.         ptr1 = ADDR(bse, off);
  584.         POP_ADDR(bse, off);
  585.         ptr3 = ADDR(bse, off);/* type of the value */
  586.         POP_ADDR(bse, off);/* to get rid of the value */
  587.         /* PUSH(qual_index(ptr1, ptr3)); */
  588.         PUSH(qual_sub(ptr1, ptr3));
  589.         break;
  590.  
  591.     case TT_C_ARRAY:
  592.     case TT_S_ARRAY:
  593.         ptr1 = ADDR(bse, off);
  594.         POP_ADDR(bse, off);
  595.         ptr3 = ADDR(bse, off);/* type of the value */
  596.         POP_ADDR(bse, off);/* to get rid of the value */
  597.         PUSH(qual_index(ptr1, ptr3));
  598.         break;
  599.  
  600.     case TT_ACCESS:
  601.         /* membership on an access type is converted into a test on the
  602.          * designated type.  If the designated type itself is an access,
  603.          * no further checks are needed.
  604.          */
  605.         POP_ADDR(bse, off);
  606.         PUSH(TRUE);
  607.         break;
  608.  
  609.     case TT_TASK:
  610.         /* Does nothing need to be checked?  This case added because
  611.          * default popped too many elements off stack - failed c45291a.
  612.          * bp - 07/04/91.
  613.          */
  614.         POP(value);
  615.         PUSH(TRUE);
  616.         break;
  617.  
  618.     default:
  619.         POP_ADDR(bse, off);
  620.         PUSH(TRUE);
  621.         break;
  622.     }
  623. }
  624.  
  625. int qual_index(int *type_ptr1, int *type_ptr2)      /*;qual_index*/
  626. {
  627.  
  628.     if (TYPE(type_ptr1) == TT_U_ARRAY || TYPE(type_ptr1) == TT_C_ARRAY) {
  629.         if (TYPE(type_ptr2) == TT_U_ARRAY || TYPE(type_ptr2) == TT_C_ARRAY) {
  630.             nb_dim = ARRAY(type_ptr1)->dim;
  631.             type_ptr1 = &(ARRAY(type_ptr1)->index1_base);
  632.             type_ptr2 = &(ARRAY(type_ptr2)->index1_base);
  633.             for (i = 1; i <= nb_dim; i++) {
  634.                 bas1 = *type_ptr1++;
  635.                 off1 = *type_ptr1++;
  636.                 ptr1 = ADDR(bas1, off1);
  637.                 bas2 = *type_ptr2++;
  638.                 off2 = *type_ptr2++;
  639.                 ptr2 = ADDR(bas2, off2);
  640.                 if (I_RANGE(ptr1)->ilow != I_RANGE(ptr2)->ilow ||
  641.                     I_RANGE(ptr1)->ihigh != I_RANGE(ptr2)->ihigh)
  642.                     return FALSE;
  643.             }
  644.         }
  645.  
  646.         else if (TYPE(type_ptr2) == TT_S_ARRAY)
  647.             return qual_index(type_ptr2, type_ptr1);
  648.  
  649.         else if (TYPE(type_ptr2) == TT_D_ARRAY) {
  650.             raise(SYSTEM_ERROR, "qual index on TT_D_ARRAY");
  651.             return FALSE;
  652. #ifdef TBSN
  653.             return qual_index(type_ptr2, type_ptr1);
  654. #endif
  655.         }
  656.     }
  657.  
  658.     else if (TYPE(type_ptr1) == TT_S_ARRAY) {
  659.         if (TYPE(type_ptr2) == TT_U_ARRAY || TYPE(type_ptr2) == TT_C_ARRAY) {
  660.             bas2 = ARRAY(type_ptr2)->index1_base;
  661.             off2 = ARRAY(type_ptr2)->index1_offset;
  662.             ptr2 = ADDR(bas2, off2);
  663.             if ( S_ARRAY(type_ptr1)->salow != I_RANGE(ptr2)->ilow
  664.               || S_ARRAY(type_ptr1)->sahigh != I_RANGE(ptr2)->ihigh) {
  665.                 return FALSE;
  666.             }
  667.         }
  668.  
  669.         else if (TYPE(type_ptr2) == TT_S_ARRAY) {
  670.             if ( S_ARRAY(type_ptr1)->salow != S_ARRAY(type_ptr2)->salow
  671.               || S_ARRAY(type_ptr1)->sahigh != S_ARRAY(type_ptr2)->sahigh) {
  672.                 return FALSE;
  673.             }
  674.         }
  675.  
  676.         else if (TYPE(type_ptr2) == TT_D_ARRAY)
  677.             return qual_index(type_ptr2, type_ptr1);
  678.     }
  679.     else if (TYPE(type_ptr1) == TT_D_ARRAY) {
  680.         raise(SYSTEM_ERROR, "qual index on TT_D_ARRAY");
  681.         return FALSE;
  682. #ifdef TBSN
  683.         if (TYPE(type_ptr2) == TT_U_ARRAY || TYPE(type_ptr2) == TT_C_ARRAY) {
  684.             nb_dim = ARRAY(type_ptr2)->dim;
  685.             ptr1 = type_ptr1 + WORDS_D_TYPE - 1;
  686.             type_ptr2 = &(ARRAY(type_ptr2)->index1_base);
  687.             for (i = 1; i <= nb_dim; i++) {
  688.                 ptr1 += 2;
  689.                 bas2 = *type_ptr2++;
  690.                 off2 = *type_ptr2++;
  691.                 ptr2 = ADDR(bas2, off2);
  692.                 if (*ptr1++ != I_RANGE(ptr2)->ilow ||
  693.                     *++ptr1 != I_RANGE(ptr2)->ihigh)
  694.                     return FALSE;
  695.             }
  696.         }
  697.  
  698.         else if (TYPE(type_ptr2) == TT_S_ARRAY) {
  699.             ptr1 = type_ptr1 + WORDS_D_TYPE + 1;
  700.             if (*ptr1++ != S_ARRAY(type_ptr2)->salow ||
  701.                 *++ptr1 != S_ARRAY(type_ptr2)->sahigh) {
  702.                 return FALSE;
  703.             }
  704.         }
  705.  
  706.         else if (TYPE(type_ptr2) == TT_D_ARRAY) {
  707.             nb_dim = D_TYPE(type_ptr2)->nb_discr_d;
  708.             ptr1 = type_ptr1 + WORDS_D_TYPE - 1;
  709.             ptr2 = type_ptr2 + WORDS_D_TYPE - 1;
  710.             for (i = 1; i <= nb_dim; i++) {
  711.                 ptr1 += 2;
  712.                 ptr2 += 2;
  713.                 if (*ptr1++ != *ptr2++ || *++ptr1 != *++ptr2)
  714.                     return FALSE;
  715.             }
  716.         }
  717. #endif
  718.     }
  719.     return TRUE;
  720. }
  721.  
  722. int qual_sub(int *type_ptr1, int *type_ptr2)         /*;qual_sub*/
  723. {
  724.     switch (TYPE(type_ptr1)) {
  725.  
  726.     case TT_I_RANGE:
  727.     case TT_E_RANGE:
  728.     case TT_ENUM:
  729.         return ((I_RANGE(type_ptr2)->ilow > I_RANGE(type_ptr2)->ihigh)
  730.           ||   ((I_RANGE(type_ptr2)->ilow >= I_RANGE(type_ptr1)->ilow)
  731.           &&    (I_RANGE(type_ptr2)->ihigh <= I_RANGE(type_ptr1)->ihigh)));
  732.  
  733.     case TT_FL_RANGE:
  734.         return ((FL_RANGE(type_ptr2)->fllow > FL_RANGE(type_ptr2)->flhigh)
  735.           ||   ((FL_RANGE(type_ptr2)->fllow >= FL_RANGE(type_ptr1)->fllow)
  736.           &&    (FL_RANGE(type_ptr2)->flhigh <= FL_RANGE(type_ptr1)->flhigh)));
  737.  
  738.     case TT_FX_RANGE:
  739.         return ((FX_RANGE(type_ptr2)->fxlow > FX_RANGE(type_ptr2)->fxhigh)
  740.            ||  ((FX_RANGE(type_ptr2)->fxlow >= FX_RANGE(type_ptr1)->fxlow)
  741.            &&  (FX_RANGE(type_ptr2)->fxhigh <= FX_RANGE(type_ptr1)->fxhigh)));
  742.  
  743.     case TT_U_ARRAY:
  744.     case TT_C_ARRAY:
  745.         if (TYPE(type_ptr2) == TT_U_ARRAY || TYPE(type_ptr2) == TT_C_ARRAY) {
  746.             nb_dim = ARRAY(type_ptr1)->dim;
  747.             type_ptr1 = &(ARRAY(type_ptr1)->index1_base);
  748.             type_ptr2 = &(ARRAY(type_ptr2)->index1_base);
  749.             for (i = 1; i <= nb_dim; i++) {
  750.                 bas1 = *type_ptr1++;
  751.                 off1 = *type_ptr1++;
  752.                 ptr1 = ADDR(bas1, off1);
  753.                 bas2 = *type_ptr2++;
  754.                 off2 = *type_ptr2++;
  755.                 ptr2 = ADDR(bas2, off2);
  756.                 if (I_RANGE(ptr2)->ilow > I_RANGE(ptr2)->ihigh) {
  757.                     continue;
  758.                 }
  759.                 else if (I_RANGE(ptr1)->ilow > I_RANGE(ptr2)->ilow ||
  760.                     I_RANGE(ptr1)->ihigh < I_RANGE(ptr2)->ihigh) {
  761.                     return FALSE;
  762.                 }
  763.             }
  764.             return TRUE;
  765.         }
  766.         else if (TYPE(type_ptr2) == TT_S_ARRAY) {
  767.             bas1 = ARRAY(type_ptr1)->index1_base;
  768.             off1 = ARRAY(type_ptr1)->index1_offset;
  769.             ptr1 = ADDR(bas1, off1);
  770.             if (S_ARRAY(type_ptr2)->salow > S_ARRAY(type_ptr2)->sahigh) {
  771.                 return TRUE;
  772.             }
  773.             if (S_ARRAY(type_ptr2)->salow < I_RANGE(ptr1)->ilow ||
  774.                 S_ARRAY(type_ptr2)->sahigh > I_RANGE(ptr1)->ihigh) {
  775.                 return FALSE;
  776.             }
  777.             return TRUE;
  778.         }
  779.         break;
  780.  
  781.     case TT_S_ARRAY:
  782.         if (TYPE(type_ptr2) == TT_U_ARRAY || TYPE(type_ptr2) == TT_C_ARRAY) {
  783.             bas2 = ARRAY(type_ptr2)->index1_base;
  784.             off2 = ARRAY(type_ptr2)->index1_offset;
  785.             ptr2 = ADDR(bas2, off2);
  786.             if (I_RANGE(ptr2)->ilow > I_RANGE(ptr2)->ihigh) {
  787.                 return TRUE;
  788.             }
  789.             if ( S_ARRAY(type_ptr1)->salow > I_RANGE(ptr2)->ilow
  790.               || S_ARRAY(type_ptr1)->sahigh < I_RANGE(ptr2)->ihigh){
  791.                 return FALSE;
  792.             }
  793.             return TRUE;
  794.         }
  795.         else if (TYPE(type_ptr2) == TT_S_ARRAY) {
  796.             if (S_ARRAY(type_ptr2)->salow > S_ARRAY(type_ptr2)->sahigh) {
  797.                 return TRUE;
  798.             }
  799.             if ( S_ARRAY(type_ptr1)->salow > S_ARRAY(type_ptr2)->salow
  800.               || S_ARRAY(type_ptr1)->sahigh < S_ARRAY(type_ptr2)->sahigh) {
  801.                 return FALSE;
  802.             }
  803.             return TRUE;
  804.         }
  805.         break;
  806.  
  807.     default:
  808.         ;
  809.     }
  810.     return TRUE;
  811. }
  812.  
  813. void qual_discr(int bse, int off)                             /*;qual_discr*/
  814. {
  815.     ptr = ADDR(bse, off);
  816.     off = TOS;
  817.     bse = TOSM(1);
  818.     if (TYPE(ptr) == TT_RECORD)
  819.         raise(SYSTEM_ERROR, "Qual discr on simple record");
  820.     else if (TYPE(ptr) == TT_U_RECORD)
  821.         return;            /* no constraint applied */
  822.     else if (TYPE(ptr) == TT_C_RECORD) {
  823.         nb_discr = C_RECORD(ptr)->nb_discr_c - 1;
  824.         ptr1 = ADDR(bse, off) + 1;/* skip constrained flag */
  825.         ptr += WORDS_C_RECORD + 1;
  826.         while (nb_discr > 0) {
  827.             if (*ptr++ != *ptr1++) {
  828.                 raise(CONSTRAINT_ERROR, "Discriminant");
  829.                 return;
  830.             }
  831.             nb_discr--;
  832.         }
  833.     }
  834.     else if (TYPE(ptr) == TT_D_RECORD) {
  835.         raise(SYSTEM_ERROR, "Qual discr on TT_D_RECORD");
  836.         return;
  837. #ifdef TBSN
  838.         nb_discr = C_RECORD(ptr)->nb_discr_c - 1;
  839.         ptr1 = ADDR(bse, off) + 1;/* skip constrained flag */
  840.         ptr += WORDS_C_RECORD + 3;
  841.         while (nb_discr > 0) {
  842.             if (*ptr++ != *ptr1++) {
  843.                 raise(CONSTRAINT_ERROR, "Discriminant");
  844.                 return;
  845.             }
  846.             ptr++;
  847.             nb_discr--;
  848.         }
  849. #endif
  850.     }
  851.     else
  852.         raise(SYSTEM_ERROR, "Unknown record type in qual discr");
  853. }
  854.  
  855. void allocate_new()                                            /*;allocate_new*/
  856. {
  857.  
  858.     POP_ADDR(bse, off);      /*  addr. of the type template for access type*/
  859.     ptr1 = ADDR(bse, off);
  860.     POP_ADDR(bse, off);      /*  addr. of the designated type */
  861.     ptr = ADDR(bse, off);
  862.     value = SIZE(ptr);
  863.     if (ACCESS(ptr1)->collection_avail > 0) {
  864.        ACCESS(ptr1)->collection_avail = ACCESS(ptr1)->collection_avail - value;
  865.     } 
  866.     else {
  867.         raise(STORAGE_ERROR, "collection exhausted");
  868.         return;
  869.     }
  870.     allocate(value, &bas2, &off2, &ptr2);
  871.  
  872.     switch(*ptr) {
  873.  
  874.     case TT_U_ARRAY:
  875.     case TT_C_ARRAY:
  876.     case TT_S_ARRAY:
  877.         if (bse < heap_base) {            /*      Non global, must make a copy */
  878.             if (TYPE(ptr) == TT_S_ARRAY) {
  879.                 val1 = WORDS_S_ARRAY;
  880.             }
  881.             else {
  882.                 nb_dim = ARRAY(ptr)->dim;
  883.                 val1 = 2 *(nb_dim - 1) + WORDS_ARRAY;
  884.             }
  885.             allocate(val1, &bse, &off, &ptr1);
  886.             for (i = 0; i < val1; i++)
  887.                 *ptr1++ = *ptr++;
  888.         }
  889.  
  890.         /* build an array descriptor */
  891.  
  892.         allocate(4, &bas1, &off1, &ptr1);
  893.         *ptr1++ = bas2;
  894.         *ptr1++ = off2;
  895.         *ptr1++ = bse;
  896.         *ptr1 = off;
  897.         PUSH_ADDR(bas1, off1);
  898.         break;
  899.  
  900.     case TT_C_RECORD:
  901.         PUSH_ADDR(bas2, off2);
  902.         *ptr2 = 1;        /*  constrained */
  903.         nb_discr = C_RECORD(ptr)->nb_discr_c;
  904.         for (i = 0; i < nb_discr; i++)
  905.             *ptr2++ = *(ptr++ + WORDS_C_RECORD);
  906.         break;
  907.  
  908.     case TT_U_RECORD:
  909.     case TT_V_RECORD:
  910.         raise(SYSTEM_ERROR, "Allocate unconstrained record");
  911.         break;
  912.  
  913.     default:
  914.         PUSH_ADDR(bas2, off2);
  915.     }
  916. }
  917.  
  918. void allocate_copy(int bse, int off)                         /*;allocate_copy*/
  919. {
  920.     POP_ADDR(bas4, off4);      /*  addr. of the type template for access type*/
  921.     ptr4 = ADDR(bas4, off4);
  922.     i = TYPE(ADDR(bse, off));
  923.     if (i == TT_U_ARRAY || i == TT_C_ARRAY || i == TT_S_ARRAY)
  924.         POP_ADDR(bse, off);
  925.     value = SIZE(ADDR(bse, off));
  926.     if (ACCESS(ptr4)->collection_avail > 0) {
  927.        ACCESS(ptr4)->collection_avail = ACCESS(ptr4)->collection_avail - value;
  928.     } 
  929.     else {
  930.         raise(STORAGE_ERROR, "collection exhausted");
  931.         return;
  932.     }
  933.     allocate(value, &bas1, &off1, &ptr1);
  934.  
  935.     switch(i) {
  936.  
  937.     case TT_U_ARRAY:
  938.     case TT_C_ARRAY:
  939.     case TT_S_ARRAY:
  940.         POP_ADDR(bas2, off2);/* value to be copied */
  941.         ptr2 = ADDR(bas2, off2);
  942.         move_mem(ptr2, ptr1, value);
  943.         bas2 = bas1;    /* build an array descriptor */
  944.         off2 = off1;
  945.         allocate(4, &bas1, &off1, &ptr1);
  946.         *ptr1++ = bas2;
  947.         *ptr1++ = off2;
  948.         *ptr1++ = bse;
  949.         *ptr1 = off;
  950.         break;
  951.  
  952.     case TT_RECORD:
  953.         POP_ADDR(bas2, off2);
  954.         ptr2 = ADDR(bas2, off2);
  955.         move_mem(ptr2, ptr1, value);
  956.         break;
  957.  
  958.     case TT_C_RECORD:
  959.     case TT_U_RECORD:
  960.         POP_ADDR(bas2, off2);
  961.         ptr2 = ADDR(bas2, off2);
  962.         move_mem(ptr2, ptr1, value);
  963.         *ptr1 = 1;        /* always constrained */
  964.         break;
  965.  
  966.     default:         /* scalar, task, or access */
  967.         if (value == 1) {
  968.             POP(val1);
  969.             *ptr1 = val1;
  970.         }
  971.         else if (value == 2) {
  972.             POP(val1);
  973.             *(ptr1 + 1) = val1;
  974.             POP(val1);
  975.             *ptr1 = val1;
  976.         }
  977.     }
  978.     PUSH_ADDR(bas1, off1);
  979. }
  980.  
  981. void fix_convert(int *fix_value, struct tt_fx_range *from_template,
  982.   struct tt_fx_range *to_template)                                /*;fix_convert*/
  983. {
  984.     /*
  985.      * DESCR: Takes a fixed point number and convert it to another fixed point
  986.      *      number.
  987.      * INPUT: value: fixed value to be converted
  988.      *      from_template: type template of value
  989.      *      to_template: target type template
  990.      * OUTPUT: the converted number
  991.      */
  992.  
  993.     int     from_exp_2, to_exp_2;
  994.     int     from_exp_5, to_exp_5;
  995.  
  996.     from_exp_5 = from_template->small_exp_5;
  997.     to_exp_5 = to_template->small_exp_5;
  998.  
  999.     from_exp_2 = from_template->small_exp_2;
  1000.     to_exp_2 = to_template->small_exp_2;
  1001.  
  1002.  
  1003.     if (from_exp_5 > to_exp_5) {
  1004.         pow_of5(mul_fact, from_exp_5 - to_exp_5);
  1005.         int_tom(div_fact,1L);
  1006.     }
  1007.     else {
  1008.         int_tom(mul_fact,1L);
  1009.         pow_of5(div_fact, to_exp_5 - from_exp_5);
  1010.     }
  1011.  
  1012.     if (from_exp_2 > to_exp_2)
  1013.         int_mp2(mul_fact, from_exp_2 - to_exp_2);
  1014.     else
  1015.         int_mp2(div_fact, to_exp_2 - from_exp_2);
  1016.  
  1017.     int_mul(fix_value, mul_fact, fix_temp);
  1018.     int_div(fix_temp, div_fact, fix_value);
  1019. }
  1020.  
  1021. int fix_out_of_bounds(long fvalue, int *itemplate)        /*;fix_out_of_bounds*/
  1022. {
  1023.     /*
  1024.      * DESCR: checks if value is out of the bounds described by template
  1025.      * INPUT: value: fixed value to be checked
  1026.      *      template: pointer to type template.
  1027.      * OUTPUT: returns TRUE if out of bounds
  1028.      */
  1029.  
  1030.     return (fvalue > FX_RANGE(itemplate)->fxhigh
  1031.       || fvalue < FX_RANGE(itemplate)->fxlow);
  1032. }
  1033.  
  1034. void create(int size, int *bse, int *off, int **ptr)            /*;create*/
  1035. {
  1036.     /* Procedure to allocate a block in memory, heap_next points to the next
  1037.      * location and is updated by the call. The parameter size is the number
  1038.      * of words to be allocated, ptr points to the newly allocated block,
  1039.      * and bse and off are set to the base and offset based on heap_base,ADDR.
  1040.      * Procedure create is only used for object creation.
  1041.      */
  1042.  
  1043.     int *p;
  1044.  
  1045.     if (size < 0 || size >max_mem) {
  1046.         raise(SYSTEM_ERROR, "Ridiculous size for object creation");
  1047.         *ptr = heap_addr + WORDS_PTR + 1;
  1048.         *off = *ptr - heap_addr;
  1049.         *bse = heap_base;
  1050.         return;
  1051.     }
  1052.     size += 1 + WORDS_PTR;
  1053.     if (heap_next > heap_addr + max_mem - size) {
  1054.         if(!allocate_new_heap()) {
  1055.             raise(STORAGE_ERROR, "Object creation");
  1056.             *ptr = heap_addr + WORDS_PTR + 1;
  1057.             *off = *ptr - heap_addr;
  1058.             *bse = heap_base;
  1059.             return;
  1060.         }
  1061.     }
  1062.  
  1063. #ifdef GARBAGE
  1064.     p = BLOCK_FRAME->bf_data_link;
  1065.     while (p) {
  1066.         if(*--p <= -size) { /* first fit */
  1067.             *p = -*p;
  1068.             p += WORDS_PTR + 1;
  1069.             *ptr = p;
  1070.             *off = *ptr - heap_addr;
  1071.             *bse = heap_base;
  1072.             return;
  1073.         }
  1074.         p = *(int **)++p;
  1075.     }
  1076.  
  1077.     int *q;
  1078.     p = free_list;
  1079.     while (p) {
  1080.         if(*--p <= -size) { /* first fit */
  1081.             *p = -*p;
  1082.             p += 1;
  1083.             q = *(int **)p;
  1084.             *(int **)p = BLOCK_FRAME->bf_data_link;
  1085.             BLOCK_FRAME->bf_data_link = free_list;
  1086.             free_list = q;
  1087.             p += WORDS_PTR;
  1088.             *ptr = p;
  1089.             *off = *ptr - heap_addr;
  1090.             *bse = heap_base;
  1091.             return;
  1092.         }
  1093.         p = *(int **)++p;
  1094.     }
  1095. #endif
  1096.  
  1097.     *heap_next++ = size;
  1098.     *(int **)(heap_next) = BLOCK_FRAME->bf_data_link;
  1099.     BLOCK_FRAME->bf_data_link = heap_next;
  1100.     heap_next += WORDS_PTR;
  1101.     *ptr = heap_next;
  1102.     *off = *ptr - heap_addr;
  1103.     *bse = heap_base;
  1104.     heap_next += size - 1 - WORDS_PTR;
  1105. }
  1106.  
  1107. void allocate(int size, int *bse, int *off, int **ptr)            /*;allocate*/
  1108. {
  1109.     /* The ALLOCATE procedure is just like CREATE except that it is used for
  1110.      * the case of an allocator allocating from the heap. It differs only
  1111.      * in the error message issued if there is insufficient room.
  1112.      */
  1113.  
  1114.     int *p;
  1115.  
  1116.     if (size < 0) {
  1117.         raise(SYSTEM_ERROR, "Ridiculous size for object allocation");
  1118.         *ptr = heap_addr + WORDS_PTR + 1;
  1119.         *off = *ptr - heap_addr;
  1120.         *bse = heap_base;
  1121.         return;
  1122.     }
  1123.     size += 1 + WORDS_PTR;
  1124.     if (heap_next > heap_addr + max_mem - size) {
  1125.         if(!allocate_new_heap()) {
  1126.             raise(STORAGE_ERROR, "Allocator");
  1127.             *ptr = heap_addr + WORDS_PTR + 1;
  1128.             *off = *ptr - heap_addr;
  1129.             *bse = heap_base;
  1130.             return;
  1131.         }
  1132.     }
  1133.  
  1134. #ifdef GARBAGE
  1135.     p = BLOCK_FRAME->bf_data_link;
  1136.     while (p) {
  1137.         if(*--p <= -size) { /* first fit */
  1138.             *p = -*p;
  1139.             p += WORDS_PTR + 1;
  1140.             *ptr = p;
  1141.             *off = *ptr - heap_addr;
  1142.             *bse = heap_base;
  1143.             return;
  1144.         }
  1145.         p = *(int **)++p;
  1146.     }
  1147.  
  1148.     int *q;
  1149.     p = free_list;
  1150.     while (p) {
  1151.         if(*--p <= -size) { /* first fit */
  1152.             *p = -*p;
  1153.             p += 1;
  1154.             q = *(int **)p;
  1155.             *(int **)p = BLOCK_FRAME->bf_data_link;
  1156.             BLOCK_FRAME->bf_data_link = free_list;
  1157.             free_list = q;
  1158.             p += WORDS_PTR;
  1159.             *ptr = p;
  1160.             *off = *ptr - heap_addr;
  1161.             *bse = heap_base;
  1162.             return;
  1163.         }
  1164.         p = *(int **)++p;
  1165.     }
  1166. #endif
  1167.  
  1168.     *heap_next++ = size;
  1169.     *(int **)(heap_next) = BLOCK_FRAME->bf_data_link;
  1170.     BLOCK_FRAME->bf_data_link = heap_next;
  1171.     heap_next += WORDS_PTR;
  1172.     *ptr = heap_next;
  1173.     *off = *ptr - heap_addr;
  1174.     *bse = heap_base;
  1175.     heap_next += size - 1 - WORDS_PTR;
  1176. }
  1177.  
  1178. void push_task_frame(int first)                            /*;push_task_frame*/
  1179. {
  1180.     if (heap_next > heap_addr + max_mem - 4 - 2*WORDS_PTR)
  1181.         raise(STORAGE_ERROR, "Tasking");
  1182.     else {
  1183.         *heap_next++ = 4 + WORDS_PTR;
  1184.         *(int **)(heap_next) = BLOCK_FRAME->bf_tasks_declared;
  1185.         heap_next += WORDS_PTR;
  1186.         BLOCK_FRAME->bf_tasks_declared = heap_next;
  1187.         *heap_next++ = first;
  1188.     }
  1189. }
  1190.  
  1191. int pop_task_frame()                                        /*;pop_task_frame*/
  1192. {
  1193.     ptr = BLOCK_FRAME->bf_tasks_declared;
  1194.     value = *ptr;        /*  Task chain */
  1195.     BLOCK_FRAME->bf_tasks_declared = *(int **)(ptr - WORDS_PTR);
  1196.     *(ptr - WORDS_PTR - 1) = -(*(ptr - WORDS_PTR - 1));/*Release task frame*/
  1197.     *(int **)(ptr - WORDS_PTR) = (int *)0;
  1198.     return (value);
  1199. }
  1200.  
  1201. void deallocate(int *p)                                            /*;deallocate*/
  1202. {
  1203.     /* Procedure to deallocate a * block. This is done simply by setting
  1204.       * the length word negative, which indicates a block which is not in use.
  1205.       */
  1206.  
  1207. #ifdef GARBAGE
  1208.     int *q,*r;
  1209.  
  1210.     if (p == (int *)0) return;
  1211.  
  1212.     q = p; /* head of list */
  1213.     while (p) {
  1214.         r = p;
  1215.         if (*--p > 0) {
  1216.             *p = -*p;
  1217.         }
  1218.         p = *(int **)r;
  1219.     }
  1220.     *(int **)r = free_list;
  1221.     free_list = q;
  1222. #else
  1223.     return;
  1224. #endif
  1225. }
  1226.  
  1227. int expn(float fvalue)                                                /*;expn*/
  1228. {
  1229.     /* this procedure is supposed to return the exponent of a normalized
  1230.      *  positive floating point number. Since it is supposed to be
  1231.      *  rewritten as an host function, we didn't try to optimize it.
  1232.      */
  1233.  
  1234.     int exponent = 0;
  1235.  
  1236.     while(fvalue < 0.5) {
  1237.         fvalue *= 2.0;
  1238.         exponent -= 1;
  1239.     }
  1240.     while(fvalue >= 1.0) {
  1241.         fvalue /= 2.0;
  1242.         exponent += 1;
  1243.     }
  1244.     return exponent;
  1245. }
  1246.  
  1247. void check_subtype_with_discr(int *type_ptr, int discr_list[])
  1248.                                                  /*;check_subtype_with_discr*/
  1249. {
  1250.     int     new_discr_list[MAX_DISCR];
  1251.     int    *base_type_ptr, *discr_ptr, nb_discr, i, *component_ptr, nb_dim;
  1252.     int        low, high;
  1253.     int     nb_field, nb_fixed, *field_ptr, *case_table_ptr, *field_table_ptr;
  1254.     int     first_field, last_field, next_case, *case_ptr;
  1255.     int     discr_number, value_discr, nb_choices;
  1256.     int        *type_ptr1, bas1, off1, *ptr1, *type_discr;
  1257.  
  1258.     if (TYPE(type_ptr) == TT_D_RECORD) {
  1259.         base_type_ptr = ADDR(D_TYPE(type_ptr)->dbase, D_TYPE(type_ptr)->doff);
  1260.         discr_ptr = type_ptr + WORDS_D_TYPE;
  1261.         nb_discr = D_TYPE(type_ptr)->nb_discr_d;
  1262.         field_ptr = base_type_ptr + WORDS_U_RECORD;
  1263.         for (i = 0; i < nb_discr; i++) {
  1264.             new_discr_list[i] = get_variable_bound(discr_ptr, discr_list);
  1265.             type_discr = ADDR (*(field_ptr+1), *(field_ptr+2));
  1266.             if ( I_RANGE(type_discr)->ilow > new_discr_list [i]
  1267.               || I_RANGE(type_discr)->ihigh < new_discr_list [i]) {
  1268.                 raise (CONSTRAINT_ERROR, "Discr. does not hold in bounds");
  1269.             }
  1270.             field_ptr += 3;
  1271.             discr_ptr += 2;
  1272.         }
  1273.         check_subtype_with_discr(base_type_ptr, new_discr_list);
  1274.  
  1275.     }
  1276.  
  1277.     else if (TYPE(type_ptr) == TT_D_ARRAY) {
  1278.         base_type_ptr = ADDR(D_TYPE(type_ptr)->dbase, D_TYPE(type_ptr)->doff);
  1279.         discr_ptr = type_ptr + WORDS_D_TYPE;
  1280.         nb_dim = D_TYPE(type_ptr)->nb_discr_d;
  1281.  
  1282.         if ( TYPE(base_type_ptr) == TT_U_ARRAY
  1283.           || TYPE(base_type_ptr) == TT_C_ARRAY) {
  1284.             component_ptr =
  1285.               ADDR(ARRAY(base_type_ptr)->component_base,
  1286.               ARRAY(base_type_ptr)->component_offset);
  1287.             check_subtype_with_discr(component_ptr, NULL_INT);
  1288.         }
  1289.         else if (TYPE (base_type_ptr) == TT_S_ARRAY) {
  1290.             /* in a simple array, the component can only be a simple
  1291.              * type : therefore there is no need to test
  1292.              */
  1293.             return;
  1294.         }
  1295.  
  1296.         type_ptr1 = &(ARRAY(base_type_ptr)->index1_base);
  1297.         for (i = 1; i <= nb_dim; i++) {
  1298.             low = get_variable_bound(discr_ptr, discr_list);
  1299.             discr_ptr += 2;
  1300.             high = get_variable_bound(discr_ptr, discr_list);
  1301.             discr_ptr += 2;
  1302.  
  1303.             bas1 = *type_ptr1++;
  1304.             off1 = *type_ptr1++;
  1305.             ptr1 = ADDR(bas1, off1);
  1306.             if ((low <= high) && (I_RANGE(ptr1)->ilow > low
  1307.               || I_RANGE(ptr1)->ihigh < high)) {
  1308.                 raise (CONSTRAINT_ERROR,
  1309.                   "Array with discr. does not hold in bounds");
  1310.             }
  1311.         }
  1312.     }
  1313.     else if (TYPE(type_ptr) == TT_C_RECORD) {
  1314.         base_type_ptr = ADDR(C_RECORD(type_ptr)->cbase,
  1315.           C_RECORD(type_ptr)->coff);
  1316.         nb_discr = C_RECORD(type_ptr)->nb_discr_c;
  1317.         field_ptr = base_type_ptr + WORDS_U_RECORD;
  1318.         for (i = 0; i < nb_discr; i++) {
  1319.             new_discr_list[i] = *(type_ptr + WORDS_C_RECORD + i);
  1320.             type_discr = ADDR (*(field_ptr+1), *(field_ptr+2));
  1321.             if ( I_RANGE(type_discr)->ilow > new_discr_list [i]
  1322.               || I_RANGE(type_discr)->ihigh < new_discr_list [i]) {
  1323.                 raise (CONSTRAINT_ERROR, "Discr. does not hold in bounds");
  1324.             }
  1325.             field_ptr += 3;
  1326.         }
  1327.         check_subtype_with_discr(base_type_ptr, new_discr_list);
  1328.     }
  1329.  
  1330.     else if (TYPE(type_ptr) == TT_V_RECORD) {
  1331.         nb_field = U_RECORD(type_ptr)->nb_field_u;
  1332.         nb_fixed = U_RECORD(type_ptr)->nb_fixed_u;
  1333.         field_table_ptr = type_ptr + WORDS_U_RECORD;
  1334.         case_table_ptr = field_table_ptr + 3 * nb_field;
  1335.         first_field = 0;
  1336.         last_field = nb_fixed - 1;
  1337.         next_case = U_RECORD(type_ptr)->first_case;
  1338.         for (;;) {
  1339.             field_ptr = 3 * first_field + field_table_ptr;
  1340.             for (i = first_field; i <= last_field; i++) {
  1341.                 component_ptr = ADDR(*(field_ptr + 1), *(field_ptr + 2));
  1342.                 check_subtype_with_discr(component_ptr, discr_list);
  1343.                 field_ptr += 3;
  1344.             }
  1345.  
  1346.             if (next_case == -1)
  1347.                 break;
  1348.  
  1349.             /* we have : next_case != -1 */
  1350.  
  1351.             case_ptr = case_table_ptr + next_case;
  1352.             discr_number = *case_ptr++;
  1353.             value_discr = discr_list[discr_number];
  1354.             nb_choices = *case_ptr;
  1355.             case_ptr += 4;
  1356.             val_high = *case_ptr;
  1357.             for (i = 2; i <= nb_choices; i++) {
  1358.                 if (val_high > value_discr)
  1359.                     break;
  1360.                 case_ptr += 4;
  1361.                 val_high = *case_ptr;
  1362.             }
  1363.             next_case = *--case_ptr;
  1364.             last_field = *--case_ptr;
  1365.             first_field = *--case_ptr;
  1366.         }
  1367.     }
  1368. }
  1369.